home *** CD-ROM | disk | FTP | other *** search
/ BMUG Revelations / BMUG Revelations.toast / Programming / Programming Languages / Yerk 3.64 / Supplement / my stuff / magnify < prev    next >
Text File  |  1992-12-23  |  3KB  |  127 lines
  1. \ rfl    sample use for class copier. A simple magnifying glass.
  2. \         need to load source 'offscreen' first
  3.  
  4. :CLASS xferer <super copier
  5.  
  6.     var        srcPort        \ source port for copying from
  7.     rect    srcRect        \ source rectangle for copying from
  8.  
  9.   :M sourceRect: put: srcRect ;M
  10.   :M sourcePort: +base put: srcPort ;M
  11.   :M drawDestRect: pushPort set: [ obj: destPort ]
  12.     get: destRect put: temprect -1 -1 inset: temprect draw: temprect
  13.     popPort ;M
  14.  
  15.   :M rowBytes: ( -- n) size: srcRect drop 15 + 4 >> 1 << ;M
  16.  
  17.   :M new: { \ myBitMap rows -- }
  18.     open: self
  19.     rowBytes: self -> rows                \ calc rowbytes
  20.     rows size: srcRect swap drop *        \ calc size of bitmap
  21.     heap> bitMap -> myBitMap            \ create bitmap on heap
  22.     rows get: srcRect put: myBitMap        \ init bitmap
  23.     myBitMap put: offScreen                \ store pointer for disposing
  24.     pushPort set: self                    \ set bitmap to grafport
  25.     myBitMap +base call setPortBits
  26.     get: srcRect ^base 16 + put: rect
  27.     popPort ;M
  28.  
  29.   :M save: obj: srcPort 2+ ^base 2+ +base
  30.     abs: srcRect (abs) 16 +
  31.     word0 0 call copyBits ;M    \ write over previous
  32.  
  33.   :M offsetDest: ( dx dy -- ) offset: destRect ;M
  34.   :M offsetSource: ( dx dy -- ) offset: srcrect ;M
  35.  
  36.   :M moveDestTo: { x y -- } x getTopX: destRect - y getTopY: destRect -
  37.     offset: destRect ;M
  38.   :M moveSourceTo: { x y -- } x getTopX: srcrect - y getTopY: srcrect -
  39.     offset: srcrect ;M
  40.  
  41. ;CLASS
  42.  
  43. :CLASS funnyWind <super window
  44.  
  45. \ hold down option key during content click to move window
  46.   :M CONTENT: mods: fevent $ 800 and
  47.     IF abs: self where: fevent -1000 dup 1000 dup put: temprect
  48.         abs: temprect call dragWindow
  49.     ELSE exec: content
  50.     THEN ;M
  51.  
  52.   :M NEW: grayRgn true setDrag: self
  53.         100 200 156 256 put: temprect
  54.         temprect 0 0 dlgWind true true new: super ;M
  55.  
  56. ;CLASS
  57.  
  58.  
  59. \ since we don't have a resource file definition, define a cursor class.
  60. :CLASS MCursor <super warray
  61.  
  62.   :M set: idxBase +base call setCursor ;M
  63.  
  64. ;CLASS
  65.  
  66. 34 MCursor squareCurs
  67.  
  68. \ load with bits for a square cursor
  69. hex
  70.     0000 0000 7ffc 4004
  71.     4004 4004 4004 4004
  72.     4004 4004 4004 4004
  73.     4004 4004 7ffc 0000
  74.  
  75.     0000 fffe fffe c006
  76.     c006 c006 c006 c006
  77.     c006 c006 c006 c006
  78.     c006 c006 fffe fffe
  79.     0008 0007
  80.  
  81. decimal
  82.  
  83. put: squareCurs
  84.  
  85. xferer bob
  86. funnyWind suz
  87.  
  88. new: suz
  89.  
  90. \ don't have a resource file here
  91. \ " magnify" openresfile
  92.  
  93. 0 0 55 55 destrect: bob
  94. 0 0 11 11 sourceRect: bob
  95. fwind sourcePort: bob
  96. suz destPort: bob
  97. new: bob
  98. set: fwind
  99.  
  100. \ If we had a cursor defined in a resource file, with ID=1000
  101. \   we could just say: '1000 cursor magcurs', and not have to define
  102. \  class MCursor
  103.  
  104. : magCurs set: squareCurs ;
  105.  
  106.  
  107. \ one way to execute a magnifier is to hold the mouse button down
  108. : magnify magcurs
  109.     BEGIN
  110.         where: theMouse 5 - swap 5 - swap moveSourceto: bob
  111.         save: bob draw: bob 
  112.         stilldown? not
  113.     UNTIL arrowcurs ;
  114.  
  115. 4 'cfas null null null magnify actions: fwind
  116.  
  117. \ load this for another way
  118. \ : magnify2 getRect: fwind put: temprect
  119. \     word0 where: theMouse pack abs: temprect call ptInRect i->l
  120. \     IF magCurs where: theMouse 5 - swap 5 - swap moveSourceto: bob
  121. \         save: bob draw: bob
  122. \     ELSE arrowcurs
  123. \     THEN ;
  124. \ 
  125. \ 'c magnify2 setidle: fwind
  126.     
  127.